home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / prolog / prlgbnc1.lha / Bench / reducer.pl < prev    next >
Text File  |  1990-07-13  |  11KB  |  376 lines
  1. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  2.  
  3. % A Graph Reducer for T-Combinators:
  4. % Reduces a T-combinator expression to a final answer.  Recognizes
  5. % the combinators I,K,S,B,C,S',B',C', cond, apply, arithmetic, tests,
  6. % basic list operations, and function definitions in the data base stored
  7. % as facts of the form t_def(_func, _args, _expr).
  8. % Written by Peter Van Roy
  9.  
  10. % Uses write/1, compare/3, functor/3, arg/3.
  11. main :-
  12.     try(fac(3), _ans1),
  13.     write(_ans1), nl,
  14.     try(quick([3,1,2]), _ans2),
  15.     write(_ans2), nl.
  16.  
  17. try(_inpexpr, _anslist) :-
  18.     listify(_inpexpr, _list),
  19.     curry(_list, _curry),
  20.     t_reduce(_curry, _ans), nl,
  21.     make_list(_ans, _anslist).
  22.  
  23. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  24.  
  25. % Examples of applicative functions which can be compiled & executed.
  26. % This test version compiles them just before each execution.
  27.  
  28. % Factorial function:
  29. t_def(fac, [N], cond(N=0, 1, N*fac(N-1))).
  30.  
  31. % Quicksort:
  32. t_def(quick, [_l], cond(_l=[], [],
  33.          cond(tl(_l)=[], _l,
  34.          quick2(split(hd(_l),tl(_l)))))).
  35. t_def(quick2, [_l], append(quick(hd(_l)), quick(tl(_l)))).
  36.  
  37. t_def(split, [_e,_l], cond(_l=[], [[_e]|[]],
  38.             cond(hd(_l)=<_e, inserthead(hd(_l),split(_e,tl(_l))),
  39.             inserttail(hd(_l),split(_e,tl(_l)))))).
  40. t_def(inserthead, [_e,_l], [[_e|hd(_l)]|tl(_l)]).
  41. t_def(inserttail, [_e,_l], [hd(_l)|[_e|tl(_l)]]).
  42.  
  43. t_def(append, [_a,_b], cond(_a=[], _b, [hd(_a)|append(tl(_a),_b)])).
  44.  
  45. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  46.  
  47. % Full reduction:
  48. % A dot '.' is printed for each reduction step.
  49.  
  50. t_reduce(_expr, _ans) :-
  51.     atomic(_expr), !,
  52.      _ans=_expr.
  53. % The reduction of '.' must be here to avoid an infinite loop
  54. t_reduce([_y,_x|'.'], [_yr,_xr|'.']) :-
  55.     t_reduce(_x, _xr),
  56.     !,
  57.     t_reduce(_y, _yr),
  58.     !.
  59. t_reduce(_expr, _ans) :-
  60.     t_append(_next, _red, _form, _expr),
  61.     write('.'),
  62.     t_redex(_form, _red),
  63.     !,
  64.     t_reduce(_next, _ans), 
  65.     !.
  66.  
  67. t_append(_link, _link, _l, _l).
  68. t_append([_a|_l1], _link, _l2, [_a|_l3]) :- t_append(_l1, _link, _l2, _l3).
  69.  
  70. % One step of the reduction:
  71.  
  72. % Combinators:
  73. t_redex([_x,_g,_f,_k|sp], [[_xr|_g],[_xr|_f]|_k]) :- t_reduce(_x, _xr).
  74. t_redex([_x,_g,_f,_k|bp], [[_x|_g],_f|_k]).
  75. t_redex([_x,_g,_f,_k|cp], [_g,[_x|_f]|_k]).
  76. t_redex([_x,_g,_f|s], [[_xr|_g]|[_xr|_f]]) :- t_reduce(_x, _xr).
  77. t_redex([_x,_g,_f|b], [[_x|_g]|_f]).
  78. t_redex([_x,_g,_f|c], [_g,_x|_f]).
  79. t_redex([_y,_x|k], _x).
  80. t_redex([_x|i], _x).
  81.  
  82. % Conditional:
  83. t_redex([_elsepart,_ifpart,_cond|cond], _ifpart) :-
  84.     t_reduce(_cond, _bool), _bool=true, !.
  85.     % Does NOT work if _bool is substituted in the call!
  86. t_redex([_elsepart,_ifpart,_cond|cond], _elsepart).
  87.  
  88. % Apply:
  89. t_redex([_f|apply], _fr) :- 
  90.     t_reduce(_f, _fr).
  91.  
  92. % List operations:
  93. t_redex([_arg|hd], _x) :- 
  94.     t_reduce(_arg, [_y,_x|'.']).
  95. t_redex([_arg|tl], _y) :- 
  96.     t_reduce(_arg, [_y,_x|'.']).
  97.  
  98. % Arithmetic:
  99. t_redex([_y,_x|_op], _res) :-
  100.     atom(_op),
  101.     member(_op, ['+', '-', '*', '//', 'mod']),
  102.     t_reduce(_x, _xres),
  103.     t_reduce(_y, _yres),
  104.     number(_xres), number(_yres),
  105.     eval(_op, _res, _xres, _yres).
  106.  
  107. % Tests:
  108. t_redex([_y,_x|_test], _res) :-
  109.     atom(_test),
  110.     member(_test, ['<', '>', '=<', '>=', '=\=', '=:=']),
  111.     t_reduce(_x, _xres),
  112.     t_reduce(_y, _yres),
  113.     number(_xres), number(_yres),
  114.     (relop(_test, _xres, _yres)
  115.     -> _res=true
  116.     ;  _res=false
  117.     ), !.
  118.  
  119. % Equality:
  120. t_redex([_y,_x|=], _res) :-
  121.     t_reduce(_x, _xres),
  122.     t_reduce(_y, _yres),
  123.     (_xres=_yres -> _res=true; _res=false), !.
  124.  
  125. % Arithmetic functions:
  126. t_redex([_x|_op], _res) :-
  127.     atom(_op),
  128.     member(_op, ['-']),
  129.     t_reduce(_x, _xres),
  130.     number(_xres),
  131.     eval1(_op, _t, _xres).
  132.  
  133. % Definitions:
  134. % Assumes a fact t_def(_func,_def) in the database for every
  135. % defined function.
  136. t_redex(_in, _out) :-
  137.     append(_par,_func,_in),
  138.     atom(_func),
  139.     t_def(_func, _args, _expr),
  140.     t(_args, _expr, _def),
  141.     append(_par,_def,_out).
  142.  
  143. % Basic arithmetic and relational operators:
  144.  
  145. eval(  '+', C, A, B) :- C is A + B.
  146. eval(  '-', C, A, B) :- C is A - B.
  147. eval(  '*', C, A, B) :- C is A * B.
  148. eval( '//', C, A, B) :- C is A // B.
  149. eval('mod', C, A, B) :- C is A mod B.
  150.  
  151. eval1('-', C, A) :- C is -A.
  152.  
  153. relop(  '<', A, B) :- A<B.
  154. relop(  '>', A, B) :- A>B.
  155. relop( '=<', A, B) :- A=<B.
  156. relop( '>=', A, B) :- A>=B.
  157. relop('=\=', A, B) :- A=\=B.
  158. relop('=:=', A, B) :- A=:=B.
  159.  
  160. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  161.  
  162. % Scheme T:
  163. % A Translation Scheme for T-Combinators
  164.  
  165. % Translate an expression to combinator form
  166. % by abstracting out all variables in _argvars:
  167. t(_argvars, _expr, _trans) :-
  168.     listify(_expr, _list),
  169.     curry(_list, _curry),
  170.     t_argvars(_argvars, _curry, _trans), !.
  171.  
  172. t_argvars([], _trans, _trans).
  173. t_argvars([_x|_argvars], _in, _trans) :-
  174.     t_argvars(_argvars, _in, _mid),
  175.     t_vars(_mid, _vars), % calculate variables in each subexpression
  176.     t_trans(_x, _mid, _vars, _trans). % main translation routine
  177.  
  178. % Curry the original expression:
  179. % This converts an applicative expression of any number
  180. % of arguments and any depth of nesting into an expression
  181. % where all functions are curried, i.e. all function
  182. % applications are to one argument and have the form
  183. % [_arg|_func] where _func & _arg are also of that form.
  184. % Input is a nested function application in list form.
  185. % Currying makes t_trans faster.
  186. curry(_a, _a) :- (var(_a); atomic(_a)), !.
  187. curry([_func|_args], _cargs) :-
  188.     currylist(_args, _cargs, _func).
  189.  
  190. % Transform [_a1, ..., _aN] to [_cN, ..., _c1|_link]-_link
  191. currylist([], _link, _link) :- !.
  192. currylist([_a|_args], _cargs, _link) :-
  193.     curry(_a, _c),
  194.     currylist(_args, _cargs, [_c|_link]).
  195.  
  196. % Calculate variables in each subexpression:
  197. % To any expression a list of the form
  198. % [_vexpr, _astr, _fstr] is matched.
  199. % If the expression is a variable or an atom
  200. % then this list only has the first element.
  201. % _vexpr = List of all variables in the expression.
  202. % _astr, _fstr = Similar structures for argument & function.
  203. t_vars(_v, [[_v]]) :- var(_v), !.
  204. t_vars(_a, [[]]) :- atomic(_a), !.
  205. t_vars([_func], [[]]) :- atomic(_func), !.
  206. t_vars([_arg|_func], [_g,[_g1|_af1],[_g2|_af2]]) :-
  207.     t_vars(_arg, [_g1|_af1]),
  208.     t_vars(_func, [_g2|_af2]),
  209.     unionv(_g1, _g2, _g).
  210.  
  211. % The main translation routine:
  212. % trans(_var, _curriedexpr, _varexpr, _result)
  213. % The translation scheme T in the article is followed literally.
  214. % A good example of Prolog as a specification language.
  215. t_trans(_x, _a, _, [_a|k]) :- (atomic(_a); var(_a), _a\==_x), !.
  216. t_trans(_x, _y, _, i) :- _x==_y, !.
  217. t_trans(_x, _e, [_ve|_], [_e|k]) :- notinv(_x, _ve).
  218. t_trans(_x, [_f|_e], [_vef,_sf,_se], _res) :-
  219.     _sf=[_vf|_],
  220.     _se=[_ve|_other],
  221.     (atom(_e); _other=[_,[_ve1|_]], _ve1\==[]),
  222.     t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, _res).
  223. t_trans(_x, [_g|[_f|_e]], [_vefg,_sg,_sef], _res) :-
  224.     _sg=[_vg|_],
  225.     _sef=[_vef,_sf,_se],
  226.     _se=[_ve|_],
  227.     _sf=[_vf|_],
  228.     t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, _res).
  229.  
  230. % First complex rule of translation scheme T:
  231. t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, _e) :-
  232.     notinv(_x, _ve), _x==_f, !.
  233. t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, [_resf,_e|b]) :-
  234.     notinv(_x, _ve), inv(_x, _vf), _x\==_f, !,
  235.     t_trans(_x, _f, _sf, _resf).
  236. t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, [_f,_rese|c]) :-
  237.     /* inv(_x, _ve), */ 
  238.     notinv(_x, _vf), !,
  239.     t_trans(_x, _e, _se, _rese).
  240. t_rule1(_x, _e, _ve, _se, _f, _vf, _sf, [_resf,_rese|s]) :-
  241.     /* inv(_x, _ve), inv(_x, _vf), */
  242.     t_trans(_x, _e, _se, _rese),
  243.     t_trans(_x, _f, _sf, _resf).
  244.  
  245. % Second complex rule of translation scheme T:
  246. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_g,_e|c]) :-
  247.     _x==_f, notinv(_x, _vg), !.
  248. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_resg,_e|s]) :-
  249.     _x==_f, /* inv(_x, _vg), */ !,
  250.     t_trans(_x, _g, _sg, _resg).
  251. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_g,_resf,_e|cp]) :-
  252.     /* _x\==_f, */ inv(_x, _vf), notinv(_x, _vg), !,
  253.     t_trans(_x, _f, _sf, _resf).
  254. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_resg,_resf,_e|sp]) :-
  255.     /* _x\==_f, */ inv(_x, _vf), /* inv(_x, _vg), */ !,
  256.     t_trans(_x, _f, _sf, _resf),
  257.     t_trans(_x, _g, _sg, _resg).
  258. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_f|_e]) :-
  259.     /* notinv(_x, _vf), */ _x==_g, !.
  260. t_rule2(_x, _e, _f, _vf, _sf, _g, _vg, _sg, [_resg,_f,_e|bp]) :-
  261.     /* notinv(_x, _vf), inv(_x, _vg), _x\==_g, */
  262.     t_trans(_x, _g, _sg, _resg).
  263.  
  264. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  265.  
  266. % List utilities:
  267.  
  268. % Convert curried list into a regular list:
  269. make_list(_a, _a) :- atomic(_a).
  270. make_list([_b,_a|'.'], [_a|_rb]) :- make_list(_b, _rb).
  271.  
  272. listify(_X, _X) :- 
  273.     (var(_X); atomic(_X)), !.
  274. listify(_Expr, [_Op|_LArgs]) :-
  275.     functor(_Expr, _Op, N),
  276.     listify_list(1, N, _Expr, _LArgs).
  277.  
  278. listify_list(I, N, _, []) :- I>N, !.
  279. listify_list(I, N, _Expr, [_LA|_LArgs]) :- I=<N, !,
  280.     arg(I, _Expr, _A),
  281.     listify(_A, _LA),
  282.     I1 is I+1,
  283.     listify_list(I1, N, _Expr, _LArgs).
  284.  
  285. member(X, [X|_]).
  286. member(X, [_|L]) :- member(X, L).
  287.  
  288. append([], L, L).
  289. append([X|L1], L2, [X|L3]) :- append(L1, L2, L3).
  290.  
  291. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  292.  
  293. % Set utilities:
  294. % Implementation inspired by R. O'Keefe, Practical Prolog.
  295. % Sets are represented as sorted lists without duplicates.
  296. % Predicates with 'v' suffix work with sets containing uninstantiated vars.
  297.  
  298. % *** Intersection
  299. intersectv([], _, []).
  300. intersectv([A|S1], S2, S) :- intersectv_2(S2, A, S1, S).
  301.  
  302. intersectv_2([], _, _, []).
  303. intersectv_2([B|S2], A, S1, S) :-
  304.         compare(Order, A, B),
  305.         intersectv_3(Order, A, S1, B, S2, S).
  306.  
  307. intersectv_3(<, _, S1, B, S2,     S) :- intersectv_2(S1, B, S2, S).
  308. intersectv_3(=, A, S1, _, S2, [A|S]) :- intersectv(S1, S2, S).
  309. intersectv_3(>, A, S1, _, S2,     S) :- intersectv_2(S2, A, S1, S).
  310.  
  311. intersectv_list([], []).
  312. intersectv_list([InS|Sets], OutS) :- intersectv_list(Sets, InS, OutS).
  313.  
  314. intersectv_list([]) --> [].
  315. intersectv_list([S|Sets]) --> intersectv(S), intersectv_list(Sets).
  316.  
  317. % *** Difference
  318. diffv([], _, []).
  319. diffv([A|S1], S2, S) :- diffv_2(S2, A, S1, S).
  320.  
  321. diffv_2([], A, S1, [A|S1]).
  322. diffv_2([B|S2], A, S1, S) :-
  323.         compare(Order, A, B),
  324.         diffv_3(Order, A, S1, B, S2, S).
  325.  
  326. diffv_3(<, A, S1, B, S2, [A|S]) :- diffv(S1, [B|S2], S).
  327. diffv_3(=, A, S1, _, S2,     S) :- diffv(S1, S2, S).
  328. diffv_3(>, A, S1, _, S2,     S) :- diffv_2(S2, A, S1, S).
  329.  
  330. % *** Union
  331. unionv([], S2, S2).
  332. unionv([A|S1], S2, S) :- unionv_2(S2, A, S1, S).
  333.  
  334. unionv_2([], A, S1, [A|S1]).
  335. unionv_2([B|S2], A, S1, S) :-
  336.         compare(Order, A, B),
  337.         unionv_3(Order, A, S1, B, S2, S).
  338.  
  339. unionv_3(<, A, S1, B, S2, [A|S]) :- unionv_2(S1, B, S2, S).
  340. unionv_3(=, A, S1, _, S2, [A|S]) :- unionv(S1, S2, S).
  341. unionv_3(>, A, S1, B, S2, [B|S]) :- unionv_2(S2, A, S1, S).
  342.  
  343. % *** Subset
  344. subsetv([], _).
  345. subsetv([A|S1], [B|S2]) :-
  346.         compare(Order, A, B),
  347.         subsetv_2(Order, A, S1, S2).
  348.  
  349. subsetv_2(=, _, S1, S2) :- subsetv(S1, S2).
  350. subsetv_2(>, A, S1, S2) :- subsetv([A|S1], S2).
  351.  
  352. % For unordered lists S1:
  353. small_subsetv([], _).
  354. small_subsetv([A|S1], S2) :- inv(A, S2), small_subsetv(S1, S2).
  355.  
  356. % *** Membership
  357. inv(A, [B|S]) :-
  358.         compare(Order, A, B),
  359.         inv_2(Order, A, S).
  360.  
  361. inv_2(=, _, _).
  362. inv_2(>, A, S) :- inv(A, S).
  363.  
  364. % *** Non-membership
  365. notinv(A, S) :- notinv_2(S, A).
  366.  
  367. notinv_2([], _).
  368. notinv_2([B|S], A) :-
  369.         compare(Order, A, B),
  370.         notinv_3(Order, A, S).
  371.  
  372. notinv_3(<, _, _).
  373. notinv_3(>, A, S) :- notinv_2(S, A).
  374.  
  375. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  376.